COMMENT ⊗   VALID 00002 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	(declare (fasload struct fas dsk (mac lsp)))
C00009 ENDMK
C⊗;
(declare (fasload struct fas dsk (mac lsp)))

(defstruct local-superclass-info
 (lattice ())
 (root ())
 (alphabetical-paths ())
 (total-order ()))

(declare (special *lattice*))
(declare (special *local-info*))

(defun init () 
       (setq *lattice* ())
       (setq *local-info* (make-local-superclass-info)))

(defmacro defclass (node superclasses ignore)
	  (push `(,node ,superclasses) *lattice*)
	  `(quote ,node))

(defun compute-alphabetical-paths (node local-info)
 (setf (alphabetical-paths local-info)
  (compute-alpha-paths node *lattice*)))

(defun compute-alpha-paths (node lattice)
 (let ((direct-superclasses (cadr (assq node lattice))))
      (cond
       ((null direct-superclasses)
	`((,node ())))
       (t
	(do ((ds direct-superclasses (cdr ds))
	     (paths-above ()))
	    ((null ds)
	     (mapcar #'(lambda (x) `(,node ,@x)) paths-above))
	    (setq paths-above
		  (append
		   paths-above
		   (compute-alpha-paths (car ds) lattice)))))))))

(defun compute-total-order (node)
 (setf (root *local-info*) node)
 (setf (total-order *local-info*) ())
 (compute-alphabetical-paths node *local-info*)
 (setf (lattice *local-info*)
       (let ((all-path-nodes 
	      (apply #'append (alphabetical-paths *local-info*))))
	    (mapcan #'(lambda (x)
			      (cond ((memq (car x) all-path-nodes) (ncons x))
				    (t nil)))
		    *lattice*)))
 (*catch 'inconsistent-lattice
	 (setf (total-order *local-info*)
	       (sort (all-nodes (lattice *local-info*)) #'cpl-less))))

(defun all-nodes (lattice)
 (mapcar #'car lattice))

(defmacro inconsistent ()
 `(progn 
   (error '|Inconsistent Lattice|)
   (*throw 'inconsistent-lattice nil)))

(defmacro when (x y)
	  `(cond (,x ,y)))

(defun cpl-less (node1 node2)
 (cond ((eq node1 node2) t)
       ((in-lattice-order node1 node2)
	(when (in-local-precedence-order node2 node1) (inconsistent))
	t)
       ((in-lattice-order node2 node1)
	(when (in-local-precedence-order node1 node2) (inconsistent))
	nil)
       ((in-local-precedence-order node1 node2))
       ((in-local-precedence-order node2 node1) nil)
       (t (in-kleene-brouwer-order node1 node2))))

(defun in-lattice-order (node1 node2)
 (let ((paths (alphabetical-paths *local-info*)))
  (do ((paths paths (cdr paths)))
      ((null paths) nil)
   (let ((subpath (memq node1 (car paths))))
    (cond ((memq node2 subpath) (return t)))))))

(defun in-local-precedence-order (node1 node2)
 (do ((lpo (lattice *local-info*) (cdr lpo)))
     ((null lpo) nil)
     (let ((greater (memq node1 (cadr (car lpo)))))
      (cond ((memq node2 greater) (return t))))))

;(defun in-kleene-brouwer-order (node1 node2)
; (let ((path1 (first-alphabetical-path-including node1))
;       (path2 (first-alphabetical-path-including node2)))
;  (do ((path1 path1 (cdr path1))
;       (path2 path2 (cdr path2)))
;      ((not (eq (car path1) (car path2)))
;       (cpl-less (car path1)(car path2))))))

(defun in-kleene-brouwer-order (node1 node2)
  (do ((path1 (alphabetical-paths *local-info*) (cdr path1))
       (some-greater nil)
       (all-less t))
      ((null path1) (and all-less (not some-greater)))
      (cond ((memq node1 (car path1))
	     (do ((path2 (alphabetical-paths *local-info*) (cdr path2)))
		 ((null path2) nil)
		 (cond ((memq node2 (car path2))
			(do ((path1 (car path1) (cdr path1))
			     (path2 (car path2) (cdr path2)))
			    ((not (eq (car path1) (car path2)))
			     (print (list (car path1)(car path2)))
			     (cond ((cpl-less (car path1)(car path2)))
				   (t (setq all-less nil)))
			     (cond ((cpl-less (car path2)(car path1))
				    (setq some-greater t))))))))))))

(defun first-alphabetical-path-including (node)
 (do ((paths (alphabetical-paths *local-info*) (cdr paths)))
     ((null paths) nil)
     (cond ((memq node (car paths)) (return (car paths))))))